Excel - Módulos com funções utilitarias

'Excel - Módulo de Acesso ao MS SQL Server

As Subs e funções abaixo permitem fazer uma consulta no MS SQL Server e trazer seus resultado numa planilha.

O trabalho é bastante facilitado pelo elemento usado para acessar o MS SQL Server - O Activex Data Access Object - para os mais íntimos, DAO. Ele devolve um recordset que pode ser facilmente colado numa planilha.
Contudo lembre-se que o VBA não possui tipos de variáveis fortemente tipadas ( veja a variável tipo variant por exemplo.). Sendo assim tome cuidado, o VBA converte facilmente e evita erros de acesso quando traz as infos do MS SQL Server já o contrario não é verdadeiro, se você está enviando um string para o ms sql server precisa colocar ele entre aspas simples e ele não converte tipos automaticamente como o vba faz.

São bons exemplos mas não se esqueça de alterar : banco de dados, base de dados, usuário, senha e até as pesquisas para o que você precisa fazer. Todas elas foram testadas e funcionam mas tive que trocar algumas informaçõe para preservar e identidade da fonte.

Importante : No Visual studio você pode usar + ou & para concatenar strings mas no VBA só use &.

Funções de acesso ao MS SQL Server

Option Explicit
'######################################################################################
'# Módulo 1 - Comunicação com o SQL Server
'######################################################################################
'O acesso do Excel ao MS SQL Server é feito via DAO
'Portanto precisamos adicionar referencias ao Microsoft Activex DataObjects
'Para isso vá até ferramentas(Tools), Referências(References)
' e selecione 'Microsoft Active X Data Objects 2.x library' - Eu selecionei a 2.8

Public Sub CarregarEmpresas()
    Dim Cn As adodb.Connection
    Dim Server_Name As String
    Dim Database_Name As String
    Dim User_ID As String
    Dim Password As String
    Dim rs As adodb.Recordset
    Set rs = New adodb.Recordset
    Dim strsql As String
    Dim NomePlanilha As String

    On Local Error GoTo saida2

    'Cabecalho_Empresas
    NomePlanilha = "Empresas"
    LimparPlanilha1 (NomePlanilha)

    strsql = "SELECT distinct emp.DESCEMPRESA, emp.EMP_COD"
    strsql = strsql & " FROM tab_empresas AS emp"
    strsql = strsql & " WHERE (emp.GRUPO NOT IN ('EMP1', 'EMP2'))"

    Server_Name = "IP_SERVIDOR"
    Database_Name = "BANCO_DE_DADOS"
    User_ID = "USUARIO"
    Password = "SENHA"

    Set Cn = New adodb.Connection
    Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & ";Uid=" & User_ID & ";Pwd=" & Password & ";"

    rs.Open strsql, Cn, adOpenStatic

    'With Worksheets(NomePlanilha).Range("a2:z500")
    ' .ClearContents
    ' .CopyFromRecordset rs
    'End With

    TransfereRecordSetParaPlanilha NomePlanilha, "A", "1", rs

    rs.Close
    Set rs = Nothing

    Sheets(NomePlanilha).Select

    MsgBox ("Os dados das Empresas carregadas com sucesso na planilha " + NomePlanilha)
    Exit Sub

saida2:
    MsgBox ("Erro:" + Err.Description)
End Sub

'muda o cabeçalho da planilha para algo que o pessoal está acostumado
Public Sub Cabecalho_PLAN1()
    Dim a As String
    Dim b() As String
    Dim NomePlanilha As String
    Dim c As Integer

    On Local Error GoTo saida3

    a = "EMP_FAT,EMP_VENDA,ESTOQUE,PLACA,MODELO,PEDIDO,CLIENTE,NOME_CLIENTE,VALOR"
    NomePlanilha = "PLANILHA2"
    b = Split(a, ",")
    Sheets(NomePlanilha).Select
    Worksheets(NomePlanilha).range("a1:zz1").ClearContents

    For c = 1 To UBound(b) + 1
        Cells(1, c).Value = b(c - 1) 'linha,coluna
        Cells(1, c).Interior.ColorIndex = 37
    Next
    Exit Sub

saida3:
    MsgBox ("Erro:" + Err.Description)

End Sub

Public Sub CarregarDadosPLANILHA2"
    Dim Cn As adodb.Connection
    Dim Server_Name As String
    Dim Database_Name As String
    Dim User_ID As String
    Dim Password As String
    Dim rs As adodb.Recordset
    Set rs = New adodb.Recordset
    Dim strsql As String * 2000
    Dim ConteudoCell As Variant
    Dim linha As Integer
    Dim NomePlanilha As String
    Dim a As Integer

    On Local Error GoTo saida4

    NomePlanilha = "PLANILHA2"
    LimparPlanilha1 (NomePlanilha)
    Cabecalho_PLAN1

    strsql = "exec [IP_SERVIDORX].BDy.dbo.procz '"

    'trazendo a lista de Cód de empresas da planilha Empresas de B1 até encontrar branco
    'Cuidado : as planilhas nem sempre tem a última linha preenchida em todas as colunas
    Sheets("Empresas").Select
    linha = 2 'linha 1 tem o header
    ConteudoCell = Cells(linha, 2).Value 'linha,coluna 2=col B

    While ConteudoCell <> ""
        strsql = Trim(strsql) & ConteudoCell & ","
        linha = linha + 1
        ConteudoCell = Cells(linha, 2).Value 'linha,coluna 2=col B
    Wend
    strsql = Left(Trim(strsql), Len(Trim(strsql)) - 1) 'retirando a ,
    strsql = Trim(strsql) & "'"

    If Len(strsql) < 100 Then
        MsgBox ("Lista de Cód de Empresas em branco")
        Exit Sub
    End If

    Server_Name = "IP_SERVIDOR"
    Database_Name = "BANCO_DE_DADOS"
    User_ID = "USUARIO"
    Password = "SENHA"

    Set Cn = New adodb.Connection
    Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & ";Uid=" & User_ID & ";Pwd=" & Password & ";"

    rs.CursorLocation = adUseClient
    rs.Open strsql, Cn, adOpenStatic 'adOpenForwardOnly

    With Worksheets(NomePlanilha).range("a2:az1000")
        .ClearContents
        .CopyFromRecordset rs
    End With

    'TransfereRecordSetParaPlanilha NomePlanilha, "A", "1", rs

    rs.Close
    Set rs = Nothing

    'celula tipo dinheiro
    a = ConverterParaNúmero("P") 'VALOR_ITEM1
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,###.00"

    'celula tipo dinheiro 'VALOR_ITEM2
    a = ConverterParaNúmero("Q")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,###.00"

    'celula tipo dinheiro 'VALOR_ITEM3
    a = ConverterParaNúmero("R")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,###.00"

    Sheets(NomePlanilha).Select

    MsgBox ("Dados PLANILHA2 Carregados com sucesso na planilha " + NomePlanilha)
        Exit Sub

saida4:
    MsgBox ("Erro:" + Err.Description)

End Sub

'coloca o cabeçalho do PROCt como o pessoal do fiscal está acostumado a ver
Public Sub Cabecalho_PROCt()
    Dim a As String
    Dim b() As String
    Dim NomePlanilha As String
    Dim c As Integer

    On Local Error GoTo saida5

    NomePlanilha = "PROCt-Servidor k"
    'LimparPlanilha1 (NomePlanilha)

    a = "COD_EMP,NOME_EMP,DESCRICAO,OFERTA, OFERECIDO"
    b = Split(a, ",")
    Sheets(NomePlanilha).Select
    Worksheets(NomePlanilha).range("a1:az1000").ClearContents

    For c = 1 To UBound(b) + 1
        Cells(1, c).Value = b(c - 1) 'linha,coluna
        Cells(1, c).Interior.ColorIndex = 37
    Next
    Exit Sub

saida5:
    MsgBox ("Erro:" + Err.Description)

End Sub

Public Sub CarregarPedidosNAOPAGOSSERVIDORd()
    Dim Cn As adodb.Connection
    Dim Server_Name As String
    Dim Database_Name As String
    Dim User_ID As String
    Dim Password As String
    Dim rs As adodb.Recordset
    Set rs = New adodb.Recordset
    Dim strsql As String
    Dim di, df As Date
    Dim sdi, sdf As String
    Dim rasc As String
    Dim NomePlanilha As String
    Dim a As Integer

    On Local Error GoTo saida6

    NomePlanilha = "PROCt-SistemaU"
    LimparPlanilha1 (NomePlanilha)
    Cabecalho_PROCt

'formatanto o período
    di = Now
    df = DateAdd("d", -1, di) 'data final : ontem
    di = DateAdd("m", -6, di) ' 6 meses antes da data corrente

    sdi = CStr(DatePart("yyyy", di))
    rasc = CStr(DatePart("m", di))
    If Len(rasc) = 1 Then
        sdi = sdi + "0" + rasc
    Else
        sdi = sdi + rasc
    End If
    rasc = CStr(DatePart("d", di))
    If Len(rasc) = 1 Then
        sdi = sdi + "0" + rasc
    Else
        sdi = sdi + rasc
    End If

    sdf = CStr(DatePart("yyyy", df))
    rasc = CStr(DatePart("m", df))
    If Len(rasc) = 1 Then
        sdf = sdf + "0" + rasc
    Else
        sdf = sdf + rasc
    End If
    rasc = CStr(DatePart("d", df))
    If Len(rasc) = 1 Then
        sdf = sdf + "0" + rasc
    Else
        sdf = sdf + rasc
    End If


    strsql = "exec PROCt_PedidoNaoPago "

    strsql = "exec PROCt_PedidoNaoPago px,'idusu', " + sdi + "," + sdf + ",py, pz, T, E, pw"

    Server_Name = "Servidorww"
    Database_Name = "Itavema_DealernetWF"
    User_ID = "USUARIO"
    Password = "SENHA"

    Set Cn = New adodb.Connection
    Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & ";Uid=" & User_ID & ";Pwd=" & Password & ";"

    rs.Open strsql, Cn, adOpenForwardOnly 'adOpenStatic

    'MsgBox rs.Fields.Count '36 campos - ok
    'Application.Calculation = xlManual

' With Worksheets(NomePlanilha).Range("a2:az1000")
' .ClearContents
' .CopyFromRecordset rs
' End With

    TransfereRecordSetParaPlanilha NomePlanilha, "A", "1", rs

    rs.Close
    Set rs = Nothing

    'celula tipo dinheiro
    a = ConverterParaNúmero("P")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,###.00"

    'celula tipo dinheiro
    a = ConverterParaNúmero("U")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,###.00"

    'convertendo celula para texto
    a = ConverterParaNúmero("F")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"

    'convertendo celula para texto
    a = ConverterParaNúmero("H")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"

    'convertendo celula para texto
    a = ConverterParaNúmero("K")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"

    'convertendo celula para texto
    a = ConverterParaNúmero("M")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"

    'convertendo celula para texto
    a = ConverterParaNúmero("O")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"

    'convertendo celula para texto
    a = ConverterParaNúmero("R")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"

    'celula tipo número
    a = ConverterParaNúmero("Z")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,##0"

    'celula tipo número
    a = ConverterParaNúmero("AA")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,##0"

    'celula tipo dinheiro
    a = ConverterParaNúmero("AB")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "#,###.00"

    'convertendo celula para texto
    a = ConverterParaNúmero("AE")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"
    'convertendo celula para texto
    a = ConverterParaNúmero("AJ")
    Sheets(NomePlanilha).Columns(a).NumberFormat = "@"

    Sheets(NomePlanilha).Select

    MsgBox ("Dados de Pedidos Não Pagos Sistema X Carregados com sucesso na planilha " + NomePlanilha)
    Exit Sub

saida6:
    MsgBox ("Erro:" + Err.Description)

End Sub

Public Sub Cab_Lancamentos()
    Dim a As String
    Dim b() As String
    Dim NomePlanilha As String
    Dim c As Integer

    On Local Error GoTo saida5

    NomePlanilha = "Lancamentos"
    'LimparPlanilha1 (NomePlanilha)

    a = "Descr, ContaBanco,CodVeiculo, Saldo, DataCaixa, Historico"
    b = Split(a, ",")
    Sheets(NomePlanilha).Select
    Worksheets(NomePlanilha).range("a1:az1000").ClearContents

    For c = 1 To UBound(b) + 1
        Cells(1, c).Value = b(c - 1) 'linha,coluna
        Cells(1, c).Interior.ColorIndex = 37
    Next
    Exit Sub

saida5:
    MsgBox ("Erro:" + Err.Description)

End Sub

Public Sub TrazerPagamentosPerdidos()
    Dim Cn As adodb.Connection
    Dim Server_Name As String
    Dim Database_Name As String
    Dim User_ID As String
    Dim Password As String
    Dim rs As adodb.Recordset
    Set rs = New adodb.Recordset
    Dim strsql As String
    Dim di, df As Date
    Dim sdi, sdf As String
    Dim NomePlanilha As String
    Dim rasc As String

    On Local Error GoTo saida7

    NomePlanilha = "Lancamentos"
    LimparPlanilha1 (NomePlanilha)

   Cab_Lancamentos

'formatanto o período
    di = Now
    df = DateAdd("d", -1, di) 'data final : ontem
    If Day(di) > 1 Then
        di = Year(di) & "-" & Month(di) & "-01" ' primeiro dia do mês corrente
    Else
        di = Year(di) & "-" & Month(di) - 1 & "-01" ' primeiro dia do mês corrente
    End If

    sdi = CStr(DatePart("yyyy", di)) & "-"
    rasc = CStr(DatePart("m", di))
    If Len(rasc) = 1 Then
        sdi = sdi & "0" & rasc & "-"
    Else
        sdi = sdi & rasc & "-"
    End If
    rasc = CStr(DatePart("d", di))
    If Len(rasc) = 1 Then
        sdi = sdi + "0" + rasc
    Else
        sdi = sdi + rasc
    End If

    sdf = CStr(DatePart("yyyy", df)) & "-"
    rasc = CStr(DatePart("m", df))
    If Len(rasc) = 1 Then
        sdf = sdf + "0" + rasc & "-"
    Else
        sdf = sdf + rasc & "-"
    End If
    rasc = CStr(DatePart("d", df))
    If Len(rasc) = 1 Then
        sdf = sdf + "0" + rasc
    Else
        sdf = sdf + rasc
    End If

    strsql = " WITH CTE AS ("
    strsql = strsql + " Select p1,"
    strsql = strsql + " p2...,"
    strsql = strsql + " from BANCOX.DBO.PROCQ Q (nolock)"
    strsql = strsql + " INNER JOIN BANCOQ.DBO.PROCU U (nolock) ON (U.PX = Q.PX and U.PY = 'S')"
    strsql = strsql + " Where Q.PR is null "
    strsql = strsql + " And CPODT >= '" + sdi + "'"
    strsql = strsql + " and CPOFT <= '" + sdf + "'"
    strsql = strsql + " Group by PQ,P2,P3 "
    strsql = strsql + " ) "
    strsql = strsql + " SELECT * FROM CTE WHERE P2=X "

    Server_Name = "IPSERVIDORP"
    Database_Name = "BANCOR"
    User_ID = "USUARIOX"
    Password = "SENHASEC"

    Set Cn = New adodb.Connection
    Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & ";Uid=" & User_ID & ";Pwd=" & Password & ";"

    rs.Open strsql, Cn, adOpenForwardOnly 'adOpenStatic

    With Worksheets(NomePlanilha).range("a2:az1000")
        .ClearContents
        .CopyFromRecordset rs
    End With

    rs.Close
    Set rs = Nothing

    Sheets(NomePlanilha).Select

    MsgBox ("Dados de Pagamentos Perdidos foram carregados com sucesso na planilha " + NomePlanilha)
        Exit Sub

saida7:
    MsgBox ("Erro:" + Err.Description)
End Sub